home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / lisp / eulisp / comp0_89.lha / Feel / Boot / Compiler / link2.em < prev    next >
Lisp/Scheme  |  1993-07-12  |  2KB  |  92 lines
  1. ;; Eulisp Module
  2. ;; Author: pab
  3. ;; File: link2.em
  4. ;; Date: Fri Apr 24 11:29:55 1992
  5. ;;
  6. ;; Project:
  7. ;; Description: 
  8. ;;   Short linker for self-install data
  9.  
  10. (defmodule link2
  11.   (standard0
  12.    list-fns
  13.    
  14.    comp-defn
  15.    stream
  16.    )
  17.   ()
  18.  
  19.   (deflocal xx nil)
  20.  
  21.   (defun link-vector (lst istate static-link)
  22.     (let ((out (make-simple-stream)))
  23.       (convert (link-vector-to-stream lst istate static-link out)
  24.            pair)))
  25.  
  26.   (defun link-vector-to-stream (lst istate static-link stream)
  27.     (labels ((link-stuff (i lst stream)
  28.              (if (null i)
  29.                  (if (null lst)
  30.                  stream
  31.                    (link-stuff (car lst) (cdr lst) stream))
  32.                (progn;;(setq xx i)
  33.                  (link-stuff (cdr i) lst 
  34.                      (write-stream-list stream (link-object (car i)))))))
  35.          ;; do strange things to an argument
  36.          (link-object  (obj)
  37.                (cond ((numberp obj)
  38.                   (list obj))
  39.                  ((eq (car obj) (the-link-handle))
  40.                   (let ((val (if (eq (cadr obj) (the-local-handle))
  41.                          (get-local-id istate (cddr obj))
  42.                            (get-non-local-id istate (cdr obj)))))
  43.                     (nconc (int2bytes (car val))
  44.                        (int2bytes (cadr val)))))
  45.                  ((eq (car obj) (the-long-handle))
  46.                   (int2bytes (cadr obj)))
  47.                  ((eq (car obj) (the-static-handle))
  48.                   (int2bytes (static-link (cdr obj))))
  49.                  ((eq (car obj) (the-local-handle))
  50.                   (int2bytes (cadr (get-local-id istate (cdr obj)))))
  51.                  (t (format t "~a~%" obj)
  52.                     (error "Whups" <clock-tick>)))))
  53.         (link-stuff nil lst stream)))
  54.  
  55.   (defun get-non-local-id (state binding)
  56.     ((cdr state) binding))
  57.  
  58.   (defun mk-local-id-mker (mod-id start mod-setter)
  59.     (let ((tab (make-table eq))
  60.       (count (mk-counter start)))
  61.       (lambda (name)
  62.     (let ((xx (table-ref tab name)))
  63.       (if (null xx)
  64.           (let ((c (count)))
  65.         (format t "(~a->~a)" name c)
  66.         ((setter table-ref) tab name c)
  67.         (mod-setter name c)
  68.         (list mod-id c))
  69.         (list mod-id xx))))))
  70.  
  71.   (defun get-local-id (state id)
  72.     ((car state) id))
  73.  
  74.   ;; making 4 bytes from integers.
  75.  
  76.   (defun int2bytes (x)
  77.     (let ((sign (< x 0))
  78.       (val (abs x)))
  79.       (let* ((v1 (/ val 256))
  80.          (v2 (/ v1 256))
  81.          (v3 (/ v2 256)))
  82.     (list (modulo v2 256)
  83.           (modulo v1 256)
  84.           (modulo val 256)
  85.           (if sign 1 0)))))
  86.       
  87.         
  88.   (export link-vector mk-local-id-mker link-vector-to-stream)
  89.  
  90.   ;; end module
  91.   )
  92.